Subclassing - Owner Drawn Menu


 Visual Basic Version: 5.0, 6.0 
 

One of the most popular questions ever since the debut of Office 97 and Visual Studio 5.0 has been, "How can I put pictures into a menu?" The following code addresses this question with the answer. 

    Standard Module QuickGDI.bas:  


Option Explicit

Dim m_hDC As Long

Public Type POINTAPI
    x As Long
    y As Long
End Type
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Declare Function CreateSolidBrush Lib "GDI32" _
     (ByVal crColor As Long) As Long
Declare Function SelectObject Lib "GDI32" _
     (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "GDI32" _
     (ByVal hObject As Long) As Integer

Declare Function GetSysColor Lib "user32" _
     (ByVal nIndex As ColConst) As Long
'Color constants for GetSysColor
Public Enum ColConst
    COLOR_ACTIVEBORDER = 10
    COLOR_ACTIVECAPTION = 2
    COLOR_ADJ_MAX = 100
    COLOR_ADJ_MIN = -100
    COLOR_APPWORKSPACE = 12
    COLOR_BACKGROUND = 1
    COLOR_BTNFACE = 15
    COLOR_BTNHIGHLIGHT = 20
    COLOR_BTNSHADOW = 16
    COLOR_BTNTEXT = 18
    COLOR_CAPTIONTEXT = 9
    COLOR_GRAYTEXT = 17
    COLOR_HIGHLIGHT = 13
    COLOR_HIGHLIGHTTEXT = 14
    COLOR_INACTIVEBORDER = 11
    COLOR_INACTIVECAPTION = 3
    COLOR_INACTIVECAPTIONTEXT = 19
    COLOR_MENU = 4
    COLOR_MENUTEXT = 7
    COLOR_SCROLLBAR = 0
    COLOR_WINDOW = 5
    COLOR_WINDOWFRAME = 6
    COLOR_WINDOWTEXT = 8
End Enum

Private Declare Function GetTextColor Lib "GDI32" _
     (ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "GDI32" _
     (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "GDI32" Alias "TextOutA" _
     (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
     ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "GDI32" _
     (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Const NEWTRANSPARENT = 3 'use with SetBkMode()

Private Declare Function CreatePen Lib "GDI32" _
     (ByVal nPenStyle As Long, ByVal nWidth As Long, _
     ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "GDI32" _
     (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
     lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "GDI32" _
     (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function Rectangle Lib "GDI32" _
     (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, _
     ByVal X2 As Long, ByVal Y2 As Long) As Long


Public Sub DrawRect(ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long)
     If m_hDC = 0 Then Exit Sub
     Call Rectangle(m_hDC, X1, Y1, X2, Y2)
End Sub

Public Function GetPen(ByVal nWidth As Long, _
ByVal Clr As Long) As Long
     GetPen = CreatePen(0, nWidth, Clr)
End Function

Public Function hPrint(ByVal x As Long, ByVal y As Long, _
ByVal hStr As String, ByVal Clr As Long) As Long
     If m_hDC = 0 Then Exit Function
     'Equivalent to setting a form's property
     'FontTransparent = True
     SetBkMode m_hDC, NEWTRANSPARENT

     Dim OT As Long
     OT = GetTextColor(m_hDC)
     SetTextColor m_hDC, Clr
     'Print the text
     hPrint = TextOut(m_hDC, x, y, hStr, Len(hStr))
     'Restore old text color
     SetTextColor m_hDC, OT
End Function

Public Property Get TargethDC() As Long
     TargethDC = m_hDC
End Property
Public Property Let TargethDC(ByVal vNewValue As Long)
     'The hDC to draw to when performing operations
     'from this module's subroutines.
     m_hDC = vNewValue
End Property

Public Sub ThreedBox(ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long, _
Optional Sunken As Boolean = False)
     'Draw a raised box around the specified
     'coordinates.

     If m_hDC = 0 Then Exit Sub

     Dim CurPen As Long, OldPen As Long
     Dim dm As POINTAPI

     If Sunken = False Then
         CurPen = GetPen(1, GetSysColor(COLOR_BTNHIGHLIGHT))
     Else
          CurPen = GetPen(1, GetSysColor(COLOR_BTNSHADOW))
     End If
     OldPen = SelectObject(m_hDC, CurPen)
     'FirstLightLine
     MoveToEx m_hDC, X1, Y2, dm
     LineTo m_hDC, X1, Y1
     'SecondLightLine
     LineTo m_hDC, X2, Y1

     SelectObject m_hDC, OldPen
     DeleteObject CurPen
     If Sunken = False Then
          CurPen = GetPen(1, GetSysColor(COLOR_BTNSHADOW))
     Else
          CurPen = GetPen(1, GetSysColor(COLOR_BTNHIGHLIGHT))
     End If
     OldPen = SelectObject(m_hDC, CurPen)
     'FirstDarkLine
     MoveToEx m_hDC, X2, Y1, dm
     LineTo m_hDC, X2, Y2
     'SecondDarkLine
     LineTo m_hDC, X1, Y2

     SelectObject m_hDC, OldPen
     DeleteObject CurPen
End Sub

'--end block--'
   

  Standard Module MenuItems.bas:  

Option Explicit
Dim hMenu As Long
Dim hSubMenu As Long
Dim mnuID As Long

Dim m_Form As frmOwnMnu

'Subclassing stuff we'll need...
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
     (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
     lParam As Any) As Long
Declare Function CallWindowProc Lib "user32" Alias _
     "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
     ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
     ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
     (ByVal hWnd As Long, ByVal nIndex As Long, _
     ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)
'Messages to use in the wndproc
Public Const WM_DRAWITEM = &H2B
Public Const WM_MEASUREITEM = &H2C
Public Const WM_MENUSELECT = &H11F
Public Const WM_COMMAND = &H111
Public Const WM_GETFONT = &H31

Type MENUITEMINFO
     cbSize As Long
     fMask As Long
     fType As Long
     fState As Long
     wID As Long
     hSubMenu As Long
     hbmpChecked As Long
     hbmpUnchecked As Long
     dwItemData As Long
     dwTypeData As Long
     cch As Long
End Type
Public Const MIIM_TYPE = &H10

Type MEASUREITEMSTRUCT
     CtlType As Long
     CtlID As Long
     itemID As Long
     itemWidth As Long
     itemHeight As Long
     ItemData As Long
End Type
Type DRAWITEMSTRUCT
     CtlType As Long
     CtlID As Long
     itemID As Long
     itemAction As Long
     itemState As Long
     hwndItem As Long
     hdc As Long
     rcItem As RECT
     ItemData As Long
End Type

Declare Function GetMenu Lib "user32" _
     (ByVal hWnd As Long) As Long
Declare Function GetSubMenu Lib "user32" _
     (ByVal hMenu As Long, ByVal nPos As Long) _
     As Long
Declare Function GetMenuItemID Lib "user32" _
     (ByVal hMenu As Long, ByVal nPos As Long) _
     As Long

Declare Function ModifyMenu Lib "user32" Alias _
     "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, _
     ByVal wFlags As Long, ByVal wIDNewItem As Long, _
     ByVal lpString As Long) As Long

Declare Function GetMenuItemInfo Lib "user32" Alias _
     "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, _
     ByVal ByPosition As Long, lpMenuItemInfo As MENUITEMINFO) _
     As Boolean

Private Const MF_BYCOMMAND = &H0
Private Const MF_BYPOSITION = &H400
Private Const MF_OWNERDRAW = &H100
Private Const MF_SEPARATOR = &H800
Public Const MFT_SEPARATOR = MF_SEPARATOR

Public Const ODS_SELECTED = &H1


Public Property Get MenuForm() As frmOwnMnu
     Set MenuForm = m_Form
End Property
Public Property Let MenuForm(ByVal vNewValue As frmOwnMnu)
     Set m_Form = vNewValue
     hMenu = GetMenu(m_Form.hWnd)
End Property

Public Property Get MenuID() As Long
     MenuID = mnuID
End Property
Public Property Let MenuID(ByVal vNewValue As Long)
     mnuID = GetMenuItemID(hSubMenu, vNewValue)
End Property

Public Sub OwnerDrawMenu(ByVal ItemData As Long)
     'Change the menu's style to owner-draw. You must
     'now subclass the form that this menu is on so
     'you can respond to the WM_MEASUREITEM and WM_DRAWITEM
     'messages.
     Dim mii As MENUITEMINFO
     mii.cbSize = Len(mii)
     mii.fMask = MIIM_TYPE
     GetMenuItemInfo hSubMenu, MenuID, False, mii
     If ((mii.fType And MF_SEPARATOR) = MF_SEPARATOR) Then
          '*Preserve* separator style...
          Call ModifyMenu(hSubMenu, MenuID, _
               MF_BYCOMMAND Or MF_OWNERDRAW Or MF_SEPARATOR, _
               MenuID, ItemData)
     Else
          Call ModifyMenu(hSubMenu, MenuID, _
               MF_BYCOMMAND Or MF_OWNERDRAW, MenuID, ItemData)
     End If
End Sub

Public Function OwnMenuProc(ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
     OwnMenuProc = frmOwnMnu.MsgProc(hWnd, wMsg, wParam, lParam)
End Function

Public Sub SetTopMenu(NewMnu As Long)
     hMenu = NewMnu
End Sub

Public Property Get SubMenu() As Long
     SubMenu = hSubMenu
End Property
Public Property Let SubMenu(ByVal vNewValue As Long)
     hSubMenu = GetSubMenu(hMenu, vNewValue)
End Property
'--end block--'
   

  Class Module PaintEffects.cls (Excerpted from Microsoft VB Owner's Area):  

Option Explicit

'Halftone created for default palette use
Private m_hpalHalftone As Long

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, _
     ByVal x As Long, ByVal y As Long, _
     ByVal hIcon As Long) As Long
Private Declare Function CreateSolidBrush Lib "GDI32" _
     (ByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Long, _
     ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
     ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, _
     ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetBkColor Lib "GDI32" (ByVal hdc As Long, _
     ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32" _
     (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "GDI32" _
     (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
     ByVal hdc As Long) As Integer
Private Declare Function CreateCompatibleBitmap Lib "GDI32" _
     (ByVal hdc As Long, ByVal nWidth As Long, _
     ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hdc As Long, _
     ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetTextColor Lib "GDI32" (ByVal hdc As Long, _
     ByVal crColor As Long) As Long
Private Declare Function CreateBitmap Lib "GDI32" (ByVal nWidth As Long, _
     ByVal nHeight As Long, ByVal nPlanes As Long, _
     ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function GetBkColor Lib "GDI32" _
     (ByVal hdc As Long) As Long
Private Declare Function GetTextColor Lib "GDI32" _
     (ByVal hdc As Long) As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hdc As Long, _
     ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32" _
     (ByVal hdc As Long) As Long
Private Declare Function CreateHalftonePalette Lib "GDI32" _
     (ByVal hdc As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" _
     (ByVal lOleColor As Long, ByVal lHPalette As Long, _
     lColorRef As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, _
     lpRect As RECT, ByVal hBrush As Long) As Integer

'Raster Operation Codes
Private Const DSna = &H220326 '0x00220326


Public Sub PaintTransparentDC(ByVal hdcDest As Long, _
               ByVal xDest As Long, _
               ByVal yDest As Long, _
               ByVal Width As Long, _
               ByVal Height As Long, _
               ByVal hdcSrc As Long, _
               ByVal XSrc As Long, _
               ByVal YSrc As Long, _
               ByVal clrMask As OLE_COLOR, _
               Optional ByVal hPal As Long = 0)

    Dim hdcMask As Long     'HDC of the created mask image
    Dim hdcColor As Long    'HDC of the created color image
    Dim hbmMask As Long     'Bitmap handle to the mask image
    Dim hbmColor As Long    'Bitmap handle to the color image
    Dim hbmColorOld As Long
    Dim hbmMaskOld As Long
    Dim hPalOld As Long
    Dim hdcScreen As Long
    Dim hdcScnBuffer As Long 'Buffer to do all work on
    Dim hbmScnBuffer As Long
    Dim hbmScnBufferOld As Long
    Dim hPalBufferOld As Long
    Dim lMaskColor As Long
    
    hdcScreen = GetDC(0&)
    'Validate palette
    If hPal = 0 Then
        hPal = m_hpalHalftone
    End If
    OleTranslateColor clrMask, hPal, lMaskColor

    'Create a color bitmap to server as a copy of the destination
    'Do all work on this bitmap and then copy it back over the
    'destination when it's done.
    hbmScnBuffer = CreateCompatibleBitmap(hdcScreen, Width, Height)
    'Create DC for screen buffer
    hdcScnBuffer = CreateCompatibleDC(hdcScreen)
    hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
    hPalBufferOld = SelectPalette(hdcScnBuffer, hPal, True)
    RealizePalette hdcScnBuffer
    'Copy the destination to the screen buffer
    BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcDest, xDest, _
        yDest, vbSrcCopy
    
    'Create a (color) bitmap for the cover (can't use
    'CompatibleBitmap with hdcSrc, because this will create a
    'DIB section if the original bitmap is a DIB section)
    hbmColor = CreateCompatibleBitmap(hdcScreen, Width, Height)
    'Now create a monochrome bitmap for the mask
    hbmMask = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
    'First, blt the source bitmap onto the cover.  We do this
    'first and then use it instead of the source bitmap
    'because the source bitmap may be
    'a DIB section, which behaves differently than a bitmap.
    '(Specifically, copying from a DIB section to a monochrome
    'bitmap does a nearest-color selection rather than painting
    'based on the backcolor and forecolor.
    hdcColor = CreateCompatibleDC(hdcScreen)
    hbmColorOld = SelectObject(hdcColor, hbmColor)
    hPalOld = SelectPalette(hdcColor, hPal, True)
    RealizePalette hdcColor
    'In case hdcSrc contains a monochrome bitmap, we must set
    'the destination foreground/background colors according to
    'those currently set in hdcSrc (because Windows will
    'associate these colors with the two monochrome colors)
    SetBkColor hdcColor, GetBkColor(hdcSrc)
    SetTextColor hdcColor, GetTextColor(hdcSrc)
    BitBlt hdcColor, 0, 0, Width, Height, hdcSrc, XSrc, _
        YSrc, vbSrcCopy
    'Paint the mask.  What we want is white at the transparent
    'color from the source, and black everywhere else.
    hdcMask = CreateCompatibleDC(hdcScreen)
    hbmMaskOld = SelectObject(hdcMask, hbmMask)

    'When bitblt'ing from color to monochrome, Windows sets to 1
    'all pixels that match the background color of the source DC.
    'All other bits are set to 0.
    SetBkColor hdcColor, lMaskColor
    SetTextColor hdcColor, vbWhite
    BitBlt hdcMask, 0, 0, Width, Height, hdcColor, 0, 0, _
        vbSrcCopy
    'Paint the rest of the cover bitmap.
    '
    'What we want here is black at the transparent color,
    'and the original colors everywhere else.  To do this,
    'we first paint the original onto the cover (which we
    'already did), then we AND the inverse of the mask onto
    'that using the DSna ternary raster operation
    '(0x00220326 - see Win32 SDK reference, Appendix,
    '"Raster Operation Codes", "Ternary
    'Raster Operations", or search in MSDN for 00220326).
    'DSna [reverse polish] means "(not SRC) and DEST".
    '
    'When bitblt'ing from monochrome to color, Windows
    'transforms all white bits (1) to the background color
    'of the destination hdc.  All black (0)
    'bits are transformed to the foreground color.
    SetTextColor hdcColor, vbBlack
    SetBkColor hdcColor, vbWhite
    BitBlt hdcColor, 0, 0, Width, Height, hdcMask, _
        0, 0, DSna
    'Paint the Mask to the Screen buffer
    BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcMask, _
        0, 0, vbSrcAnd
    'Paint the Color to the Screen buffer
    BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcColor, _
        0, 0, vbSrcPaint
    'Copy the screen buffer to the screen
    BitBlt hdcDest, xDest, yDest, Width, Height, _
        hdcScnBuffer, 0, 0, vbSrcCopy
    'All done!
    DeleteObject SelectObject(hdcColor, hbmColorOld)
    SelectPalette hdcColor, hPalOld, True
    RealizePalette hdcColor
    DeleteDC hdcColor
    DeleteObject SelectObject(hdcScnBuffer, hbmScnBufferOld)
    SelectPalette hdcScnBuffer, hPalBufferOld, True
    RealizePalette hdcScnBuffer
    DeleteDC hdcScnBuffer

    DeleteObject SelectObject(hdcMask, hbmMaskOld)
    DeleteDC hdcMask
    ReleaseDC 0&, hdcScreen
End Sub


Public Sub PaintTransparentStdPic(ByVal hdcDest As Long, _
                ByVal xDest As Long, _
                ByVal yDest As Long, _
                ByVal Width As Long, _
                ByVal Height As Long, _
                ByVal picSource As Picture, _
                ByVal XSrc As Long, _
                ByVal YSrc As Long, _
                ByVal clrMask As OLE_COLOR, _
                Optional ByVal hPal As Long = 0)

    Dim hdcSrc As Long 'HDC for source bitmap
    Dim hbmMemSrcOld As Long
    Dim hbmMemSrc As Long
    Dim udtRect As RECT
    Dim hbrMask As Long
    Dim lMaskColor As Long
    Dim hdcScreen As Long
    Dim hPalOld As Long
    'Verify that the passed picture is a Bitmap
    If picSource Is Nothing Then GoTo _
        PaintTransparentStdPic_InvalidParam
    
    Select Case picSource.Type
        Case vbPicTypeBitmap
            hdcScreen = GetDC(0&)
            'Validate palette
            If hPal = 0 Then
                hPal = m_hpalHalftone
            End If
            'Select passed picture into an HDC
            hdcSrc = CreateCompatibleDC(hdcScreen)
            hbmMemSrcOld = SelectObject(hdcSrc, picSource.Handle)
            hPalOld = SelectPalette(hdcSrc, hPal, True)
            RealizePalette hdcSrc
            'Draw the bitmap
            PaintTransparentDC hdcDest, xDest, yDest, _
                Width, Height, hdcSrc, XSrc, YSrc, clrMask, hPal

            SelectObject hdcSrc, hbmMemSrcOld
            SelectPalette hdcSrc, hPalOld, True
            RealizePalette hdcSrc
            DeleteDC hdcSrc
            ReleaseDC 0&, hdcScreen
        Case vbPicTypeIcon
            'Create a bitmap and select it into an DC
            hdcScreen = GetDC(0&)
            'Validate palette
            If hPal = 0 Then
                hPal = m_hpalHalftone
            End If
            hdcSrc = CreateCompatibleDC(hdcScreen)
            hbmMemSrc = CreateCompatibleBitmap(hdcScreen, _
                Width, Height)
            hbmMemSrcOld = SelectObject(hdcSrc, hbmMemSrc)
            hPalOld = SelectPalette(hdcSrc, hPal, True)
            RealizePalette hdcSrc
            'Draw Icon onto DC
            udtRect.Bottom = Height
            udtRect.Right = Width
            OleTranslateColor clrMask, 0&, lMaskColor
            hbrMask = CreateSolidBrush(lMaskColor)
            FillRect hdcSrc, udtRect, hbrMask
            DeleteObject hbrMask
            DrawIcon hdcSrc, 0, 0, picSource.Handle
            'Draw Transparent image
            PaintTransparentDC hdcDest, xDest, yDest, Width, _
                Height, hdcSrc, 0, 0, lMaskColor, hPal
            'Clean up
            DeleteObject SelectObject(hdcSrc, hbmMemSrcOld)
            SelectPalette hdcSrc, hPalOld, True
            RealizePalette hdcSrc
            DeleteDC hdcSrc
            ReleaseDC 0&, hdcScreen
        Case Else
            GoTo PaintTransparentStdPic_InvalidParam
    End Select
    Exit Sub
PaintTransparentStdPic_InvalidParam:
    Exit Sub
End Sub
'--end block--'
   

  Form frmOwnMnu.frm  


  
Add some menus to this form in the following structure:

	&File (mnuFile)
	.... &New (mnuNew)
	.... &Open (mnuOpen)
	.... &Save (mnuSave)
	.... Save &As... (mnuSaveAs)
	.... - (sep)
	.... E&xit (mnuExit)
	&Edit (mnuEdit)
	.... &Undo (mnuUndo)
	.... - (sep2)
	.... Cu&t (mnuCut)
	.... &Copy (mnuCopy)
	.... &Paste (mnuPaste)
	.... - (sep3)
	.... &Bookmarks (mnuBookmarks)
	........ Toggle Bookmark (mnuToggle)
	........ Next Bookmark (mnuNext)
	........ Previous Bookmark (mnuPrevious)
	........ Clear All Bookmarks (mnuClearAll)

Add a Label to the form named lblNum, and CommandButton named cmdPicMnu, and a control array of Images named img, with indexes from (0) to (19). Not all of these Image controls will contain bitmaps, but the code we'll add needs an Image control for each menu item to determine whether the menu item uses a bitmap.
Unzip this file (ownmenu.zip) to get the bitmaps I used for this demo and assign them to the following Image controls:

img(2) - "New.bmp"
img(3) - "Open.bmp"
img(4) - "Save.bmp"

img(9) - "Undo.bmp"

img(11) - "Cut.bmp"
img(12) - "Copy.bmp"
img(13) - "Paste.bmp"

img(16) - "Bookmark.bmp"
img(17) - "NextBookmark.bmp"
img(18) - "PreviousBookmark.bmp"
img(19) - "ClearBookmark.bmp"

That's it for the visual design of the form! It's time to add the code that makes all this work:

Option Explicit 

Dim pnt As PaintEffects

Dim MyFont As Long
Dim OldFont As Long

Dim wlOldProc As Long

Dim Caps(2 To 19) As String
Private Declare Sub CopyMem Lib "kernel32" Alias _
     "RtlMoveMemory" (pDest As Any, pSource As Any, _
     ByVal ByteLen As Long)


Private Sub Form_Load()

     Move (Screen.Width - Width) \ 2, _
          (Screen.Height - Height) \ 2

     Set pnt = New PaintEffects

     Caps(2) = "New"
     Caps(3) = "Open"
     Caps(4) = "Save"
     Caps(5) = "Save As..."
     Caps(6) = ""
     Caps(7) = "Exit"

     Caps(9) = "Undo"
     Caps(10) = ""
     Caps(11) = "Cut"
     Caps(12) = "Copy"
     Caps(13) = "Paste"
     Caps(15) = "Bookmarks"

     Caps(16) = "Toggle Bookmark"
     Caps(17) = "Next Bookmark"
     Caps(18) = "Previous Bookmark"
     Caps(19) = "Clear All Bookmarks"

End Sub

Private Function HiWord(LongIn As Long) As Integer
     HiWord = (LongIn And &HFFFF0000) \ &H10000
End Function

Public Function IsSeparator(ByVal IID As Integer) As Boolean
     Dim mii As MENUITEMINFO
     mii.cbSize = Len(mii)
     mii.fMask = MIIM_TYPE
     mii.wID = IID
     GetMenuItemInfo GetMenu(hWnd), IID, False, mii
     IsSeparator = ((mii.fType And MFT_SEPARATOR) = MFT_SEPARATOR)
End Function

Private Function LoWord(LongIn As Long) As Integer
     If (LongIn And &HFFFF&) > &H7FFF Then
          LoWord = (LongIn And &HFFFF&) - &H10000
     Else
          LoWord = LongIn And &HFFFF&
     End If
End Function


Public Function MsgProc(ByVal hWnd As Long, ByVal wMsg As Long, _
     ByVal wParam As Long, ByVal lParam As Long) As Long

'This procedure is called because we've subclassed
'this form. We will catch DRAWITEM and MEASUREITEM
'messages and pass the rest of them on.

'Various structs we'll need
Dim MeasureInfo As MEASUREITEMSTRUCT
Dim DrawInfo As DRAWITEMSTRUCT
Dim mii As MENUITEMINFO
'Set later for separator flag:
Dim IsSep As Boolean
'Our custom brush and the old one
Dim hBr As Long, hOldBr As Long
'Our custom pen and the old one
Dim hPen As Long, hOldPen As Long
'The text color of the menu items
Dim lTextColor As Long
'Now much to bump the menu's selection
'rectangle over
Dim iRectOffset As Integer

If wMsg = WM_DRAWITEM Then
     If wParam = 0 Then 'It was sent by the menu
          'Get DRAWINFOSTRUCT -- copy it to our
          'empty structure from the pointer in lParam
          Call CopyMem(DrawInfo, ByVal lParam, LenB(DrawInfo))
          IsSep = IsSeparator(DrawInfo.itemID)

          '===Set the menu font through its hDC...===
          MyFont = SendMessage(Me.hWnd, WM_GETFONT, 0&, 0&)
          OldFont = SelectObject(DrawInfo.hdc, MyFont)
          'We draw the item based on Un/Selected:
          If DrawInfo.itemState = ODS_SELECTED Then
               hBr = CreateSolidBrush( _
                    GetSysColor(COLOR_HIGHLIGHT))
               hPen = GetPen(1, GetSysColor(COLOR_HIGHLIGHT))
               lTextColor = GetSysColor(COLOR_HIGHLIGHTTEXT)
          Else
               hBr = CreateSolidBrush(GetSysColor(COLOR_MENU))
               hPen = GetPen(1, GetSysColor(COLOR_MENU))
               lTextColor = GetSysColor(COLOR_MENUTEXT)
          End If
          'We're going to draw on the menu
          QuickGDI.TargethDC = DrawInfo.hdc
          'Select our new, correctly colored objects:
          hOldBr = SelectObject(DrawInfo.hdc, hBr)
          hOldPen = SelectObject(DrawInfo.hdc, hPen)
          With DrawInfo.rcItem
          If DrawInfo.itemState <> ODS_SELECTED Then
                    'Clear the space where the image is
               QuickGDI.DrawRect .Left, .Top, _
                    22, .Bottom
          End If
          'Check to see if the menu item is one of the
          'ones with a picture. If so, then we need to
          'move the edge of the drawing rectangle a little
          'to the left to make room for the image.
          iRectOffset = IIf(img(DrawInfo.itemID).Picture _
               <> 0, 23, 0)
          'Do we have a separator bar?
          If Not IsSep Then
               'Draw the rectangle onto the item's space
               QuickGDI.DrawRect .Left + iRectOffset, _
                    .Top, .Right, .Bottom
               'Print the item's text
               '(held in the Caps() array)
               hPrint .Left + 25, .Top + 3, _
                    Caps(DrawInfo.itemID), _
                    lTextColor
          End If
          End With
          'Select the old objects into the menu's DC
          Call SelectObject(DrawInfo.hdc, hOldBr)
          Call SelectObject(DrawInfo.hdc, hOldPen)
          'Delete the ones we created
          Call DeleteObject(hBr)
          Call DeleteObject(hPen)
          With DrawInfo
          'If the item had an image:
          '2 = New, 3 = Open, 4 = Save, etc.
          If img(.itemID).Picture.Handle <> 0 Then
               pnt.PaintTransparentStdPic .hdc, _
                    4, .rcItem.Top + 2, _
                    16, 16, img(.itemID).Picture, _
                    0, 0, &HC0C0C0
               'If this item is selected, draw a raised
               'box around the image
               If DrawInfo.itemState = ODS_SELECTED Then
                    ThreedBox 1, .rcItem.Top, 21, _
                         .rcItem.Bottom - 1
               End If
          End If
          If IsSep Then
               'Draw the special separator bar
               ThreedBox .rcItem.Left, _
                    .rcItem.Top + 2, _
                    .rcItem.Right - 1, _
                    .rcItem.Bottom - 2, True
          End If
          End With
     End If
     'Don't pass this message on:
     MsgProc = False
     Exit Function

ElseIf wMsg = WM_MEASUREITEM Then
     'Get the MEASUREITEM struct from the pointer
     Call CopyMem(MeasureInfo, ByVal lParam, Len(MeasureInfo))
     IsSep = IsSeparator(MeasureInfo.itemID)
     'Tell Windows how big our items are.
     MeasureInfo.itemWidth = 120
     'If the item being measured is the separator
     'bar, the height should be 5 pixels, 18 if
     'otherwise...
     MeasureInfo.itemHeight = IIf(IsSep, 5, 20)
     'Return the information back to Windows
     Call CopyMem(ByVal lParam, MeasureInfo, Len(MeasureInfo))
     'Don't pass this message on:
     MsgProc = False
     Exit Function
ElseIf wMsg = WM_MENUSELECT Then
     lblNum.Caption = LoWord(wParam) & ", (" & HiWord(wParam) & ")"

End If

'We didn't handle this message,
'pass it on to the next WndProc
MsgProc = CallWindowProc(wlOldProc, hWnd, wMsg, wParam, lParam)

End Function


Private Sub cmdPicMnu_Click()
     If wlOldProc <> 0 Then Exit Sub

     Dim i As Integer

     MenuItems.MenuForm = Me
     'Start with File menu
     MenuItems.SubMenu = 0
     For i = 0 To 5
          MenuItems.MenuID = i
          OwnerDrawMenu (i + 2)
     Next
     'Next comes Edit menu...
     MenuItems.SubMenu = 1
     For i = 0 To 6 '7 To 13
          MenuItems.MenuID = i
          OwnerDrawMenu (i + 2)
     Next
     'Then the Bookmarks menu (under Edit)
     SetTopMenu MenuItems.SubMenu
     MenuItems.SubMenu = 6
     For i = 0 To 3 '16 To 19
          MenuItems.MenuID = i
          OwnerDrawMenu (i + 2)
     Next
     wlOldProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf OwnMenuProc)

End Sub

Private Sub Form_Unload(Cancel As Integer)
     If wlOldProc <> 0 Then
          SetWindowLong hWnd, GWL_WNDPROC, wlOldProc
     End If
     Set pnt = Nothing

     'Destroy the font object created in
     'the form's window procedure.
     Call DeleteObject(MyFont)

End Sub
'--end block--'
 

 Finishing Up 
  
Save, and run the project. Notice that the menus only look like regular Windows menus - no fancy doodads at all. Now click the cmdPicMnu button. Your menus instantly become graphical, and look just like those seen in Office 97! 

  
  


--------------------------------------------------------------------------------

 
 
